home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 004 / almanac.arc / ALMAN-S.BAS (.txt) < prev   
Encoding:
GW-BASIC  |  1987-04-12  |  9.0 KB  |  327 lines
  1. 5  PRINT "Some people are Weatherwise, most people are otherwise."
  2. 10  REM ALMANAC FOR A WEATHER PERSON
  3. 20  REM WRITTEN BY ALFRED K. BLACKADAR
  4. 30  REM ROOM 503 WALKER BLDG
  5. 40  REM UNIVERSITY PARK, PA 16802
  6. 50  REM
  7. 60  READ LO,LA
  8. 70  REM SUBSTITUTE YOUR OWN LONGITUDE AND LATITUDE
  9. 80  REM IN STEP 100. USE DECIMAL DEGREES.
  10. 90  REM EAST LONGITUDES ARE NEGATIVE, WEST POSITIVE
  11. 100  DATA 90.1833,38.633
  12. 110  READ PI,OB,L0,L1,A0,A1,E,EO
  13. 120  DATA 3.141592654,.409095,4.88376619,.017202791
  14. 130  DATA 6.23471229,.017201970,.016728,.00218
  15. 140  TR=PI/180 : FC=2*PI
  16. 150  SL=15*INT(LO/15+0.5) : REM STANDARD LONGITUDE
  17. 160  REM TO SHIFT ONE TIME ZONE WEST, INSERT STEP
  18. 170  REM "175 SL=SL+15"; "-" IN LIEU OF "+" IF EAST
  19. 180  TZ=SL/15-4 : REM SELECTS ZONE-TIME LABEL
  20. 190  LO=LO*TR : LA=LA*TR : SL=SL*TR
  21. 200  REM D STRINGS ARE GROUPS OF 9 CHARS * SPACES
  22. 210  D1$="SUNDAY   MONDAY   TUESDAY  WEDNESDAY"
  23. 220  D2$="THURSDAY FRIDAY   SATURDAY "
  24. 230  D$=D1$+D2$ : X$=" ** "
  25. 240  M$="JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC"
  26. 250  Z$="ASTESTCSTMSTPSTYSTASTADTEDTCDTMDTPDTYDTADT"
  27. 260  TN=LO/FC+0.5 : REM LONGITUDE TIME OFFSET + 12 HR
  28. 270  PRINT "DAY"; : INPUT D
  29. 280  PRINT "MONTH (#)"; : INPUT M
  30. 290  IF M>12 THEN PRINT "INVALID DATE" : GOTO 280
  31. 300  PRINT "YEAR"; : INPUT YR
  32. 310  X=1 : Y=1 : GOSUB 2410
  33. 320  T9=T : REM TIME MARK FOR 1ST DAY OF YEAR
  34. 330  X=D : Y=M : GOSUB 2410
  35. 340  YD=T-T9+1 : REM DAY OF YEAR
  36. 350  X=INT(T+1)/7 : Y=INT(X)
  37. 360  WD=INT(7*(X-Y)+0.5) : REM DAY OF THE WEEK
  38. 370  REM NEXT T IS DAYS AFTER 0HR GMT 1/1/1980
  39. 380  T=T+3449.5+TN
  40. 385  DT=0.000589999+2E-08*T : T=T+DT
  41. 390  CLS
  42. 400  PRINT TAB(15);"ALMANAC - SAINT LOUIS, MISSOURI    ";
  43. 410  PRINT MID$(D$,9*WD+1,9);
  44. 420  PRINT D;MID$(M$,3*(M-1)+1,3);YR
  45. 430  PRINT TAB(20);"Day of Year";YD;"         Julian Day";INT(JD+1)
  46. 440  PRINT TAB(38);"SUN"
  47. 450  REM MAKE SUMMER TIME SHIFT AS NEEDED
  48. 460  REM IF NO SUMMER TIME, OMIT STEP 500.
  49. 470  REM TO ALTER DATES OF SHIFT, ADD (ALGBR'LY)
  50. 480  REM REQ'D # OF DAYS TO "113" AND "298"
  51. 490  X=YD-WD : S2=SL-15*TR
  52. 500  IF X>113 THEN IF X<298 THEN TZ=TZ+7 : SL=S2
  53. 510  T$=MID$(Z$,3*TZ+1,3)
  54. 610  GOSUB 2860 : REM FIND SUN AT LOCAL NOON
  55. 620  IF DE>PI THEN DE=DE-FC
  56. 630  Q=ML-RA : REM EQ OF TIME (NOT DISPLAYED)
  57. 660  PRINT TAB(15);"Declination";INT(DE*100/TR+0.5)/100;" deg.";
  58. 670  PRINT "        Distance";RV;" A.U.": PRINT TAB(17);"Rises";
  59. 680  X=-0.014539 : GOSUB 2360
  60. 690  IF ABS(Y)<1 THEN 720
  61. 700  PRINT X$;X$;T$;"             Sets";X$;X$;T$
  62. 710  GOTO 780
  63. 720  S0=Z*(1+L1/FC) :H=-S0 : GOSUB 2260
  64. 724  TC=0.00274*S0*SIN(OB)*COS(TL)*SIN(LA)
  65. 725  Z=SIN(S0)*COS(LA)*(COS(DE)^3)
  66. 726  TC=TC/Z
  67. 730  X=ZT+TC+EO : GOSUB 2310
  68. 740  PRINT X;Y;T$;"                Sets";
  69. 750  H=S0 : GOSUB 2260
  70. 760  X=ZT+TC+EO : GOSUB 2310
  71. 770  PRINT X;Y;T$
  72. 780  PRINT TAB(27);"Transits Meridian";
  73. 790  IF ABS(LA-DE)>PI/2 THEN PRINT X$;X$;T$ : GOTO 830
  74. 800  H=0 : GOSUB 2260
  75. 810  X=ZT : GOSUB 2310
  76. 820  PRINT X;Y;Z;T$
  77. 830  GOSUB 3000
  78. 850  REM OPTIONAL MOONRISE/SET MODULE
  79. 860  PRINT TAB(37);"MOON" : PRINT TAB(17);"Rises";
  80. 870  A=-1 : ZT=PI : GOSUB 2710
  81. 880  X=ZT+EO : GOSUB 2310
  82. 890  IF A<>1000 THEN 910
  83. 900  PRINT X$;X$;T$ : GOTO 920
  84. 910  PRINT X;Y;T$;
  85. 920  PRINT "            Sets";
  86. 930  A=1 : ZT=PI : GOSUB 2710
  87. 940  X=ZT+EO : GOSUB 2310
  88. 950  IF A<>1000 THEN 970
  89. 960  PRINT X$;X$;T$ : GOTO 980
  90. 970  PRINT X;Y;T$
  91. 980  PRINT TAB(27);"Transits Meridian";
  92. 990  A=0 : ZT=PI : GOSUB 2710
  93. 1000  X=ZT+EO : GOSUB 2310
  94. 1010  IF A<>1000 THEN 1030
  95. 1020  PRINT X$;X$;T$ : GOTO 1040
  96. 1030  PRINT X;Y;T$
  97. 1040  Z=T : GOSUB 2510
  98. 1050  X=PI-(X0-TL) : PH=INT(50*(1+COS(X)))/100
  99. 1060  PRINT TAB(24);"Phase";PH;"(Full = 1, New = 0)"
  100. 1070  X=SIN(D0) : Y=COS(D0) : GOSUB 2010
  101. 1080  A=INT(Z*2953.06/FC)/100
  102. 1090  PRINT TAB(21);"Age of Mean Moon (for clocks):";A;"DAYS"
  103. 1100  REM END OF MOON MODULE
  104. 1530  PRINT TAB(8);"PRESS ANY KEY TO CONTINUE         ";
  105. 1540  A$=INKEY$ : IF A$="" THEN 1540
  106. 1990  GOTO 4000
  107. 1995  IF A$ <> "YES" THEN END ELSE RUN
  108. 2000  REM SUBR Z=ARCTAN(X/Y)
  109. 2001  REM 0<= Z < 2*PI
  110. 2010  C=0 : N=0
  111. 2015  PI=3.14159
  112. 2020  IF Y<>0 THEN 2050
  113. 2030  Z=0 : C=1
  114. 2035  IF X<0 THEN N=1
  115. 2040  GOTO 2060
  116. 2050  Z=X/Y
  117. 2060  Z=ATN(Z)
  118. 2070  IF C=1 THEN Z=PI/2-Z
  119. 2080  IF N=1 THEN Z=-Z
  120. 2090  IF Y<0 THEN Z=Z+PI
  121. 2100  IF Z<0 THEN Z=Z+2*PI
  122. 2110  RETURN
  123. 2150  REM ZENITH ANGLE ZA AND AZIMUTH AZ FROM H AND DE
  124. 2160  CZ=SIN(LA)*SIN(DE)+COS(LA)*COS(DE)*COS(H)
  125. 2165  SZ=SQR(1-CZ^2): ZA=ATN(SZ/CZ)
  126. 2170  IF ZA<0 THEN ZA=ZA+PI
  127. 2175  X=COS(DE)*SIN(H)/SZ
  128. 2180  Y=(SIN(LA)*CZ-SIN(DE))/(SZ*COS(LA))
  129. 2185  GOSUB 2010
  130. 2190  AZ=Z : IF AZ>PI THEN AZ=AZ-FC
  131. 2195  RETURN
  132. 2200  REM H=LHA FROM RADIAN ZONE TIME ZT AND RA
  133. 2210  H=ZT+SL-RA-LO+ML+PI
  134. 2220  IF H>PI THEN H=H-FC
  135. 2230  RETURN
  136. 2245  PX=3423+187*COS(M1)+34+COS(M1-2*D0)+28*COS(2*D0)
  137. 2250  REM RADIAN ZONE TIME ZT FROM H=LHA, RA
  138. 2260  FOR IJ=1 TO 5
  139. 2265  ZT=H+RA+LO-SL-ML-PI
  140. 2270  X=SIN(ZT) : Y=COS(ZT) : GOSUB 2010
  141. 2275  ML=L0+L1*(T-TN+(SL+Z)/FC) : NEXT IJ
  142. 2280  ZT=Z : RETURN
  143. 2300  REM CONVERT ANGULAR TIME X
  144. 2301  REM TO X=HR, Y=MIN, Z=SEC
  145. 2310  W=X*24/FC : X=INT(W)
  146. 2320  Z=(W-X)*60 : Y=INT(Z)
  147. 2330  Z=INT((Z-Y)*60) : RETURN
  148. 2350  REM Z=LHA FROM X=COS(ZENITH ANGLE)
  149. 2360  Y=(X-SIN(LA)*SIN(DE))/(COS(LA)*COS(DE))
  150. 2370  IF ABS(Y)>1 THEN 2390
  151. 2380  X=SQR(1-Y^2) : GOSUB 2010
  152. 2390  RETURN
  153. 2400  REM JULIAN DAY (JD) FROM DATE
  154. 2401  REM X=DAY, Y=MONTH, YR=YEAR
  155. 2410  T=367*(YR-1980)
  156. 2420  T=T-INT(7*(YR+INT((Y+9)/12))/4)
  157. 2430  S=SGN(Y-9) : A=ABS(Y-9)
  158. 2440  Z=INT((YR+S*INT(A/7))/100)
  159. 2450  T=T-INT(3*(Z+1)/4)
  160. 2460  T=T+INT(275*Y/9)+X-0.5
  161. 2470  JD=T+2.44769E+06
  162. 2480  RETURN
  163. 2500  REM FIND RIGHT ASCENSION RA AND DECLINATION
  164. 2501  REM DE OF MOON GIVEN THE TIME  Z
  165. 2510  M1=1.54736+0.228027*Z : REM MEAN ANOMALY
  166. 2520  A3=A0+A1*Z : REM SUN'S MEAN ANOMALY
  167. 2530  M3=1.36401+0.229972*Z
  168. 2540  D0=2.76343+0.212769*Z
  169. 2550  F0=4.99608+0.230896*Z
  170. 2560  X=109760*SIN(M1)-22236*SIN(M1-2*D0)
  171. 2570  X=109760*SIN(M1)-22236*SIN(M1-2*D0)
  172. 2571  X=X-11490*SIN(2*D0)+3728*SIN(2*M1)
  173. 2572  X=X-3232*SIN(A3)-1996*SIN(2*F0)
  174. 2590  X0=M3+9.99E-07*X : REM MOON'S TRUE LONGITUDE
  175. 2600  X=89503*SIN(F0)+4897*SIN(M1+F0)
  176. 2601  X=X+4847*SIN(M1-F0)-3023*SIN(F0-2*D0)
  177. 2610  X=X+4847*SIN(M1-F0)-3023*SIN(F0-2*D0)
  178. 2620  X=COS(Y2)*SIN(X0)*COS(OB)-SIN(Y2)*SIN(OB)
  179. 2630  Y=COS(Y2)*COS(X0) : GOSUB 2010
  180. 2640  RA=Z
  181. 2650  X=COS(Y2)*SIN(X0)*SIN(OB)+SIN(Y2)*COS(OB)
  182. 2660  Y=COS(Y2)*COS(X0)/COS(RA)
  183. 2670  GOSUB 2010
  184. 2680  DE=Z : IF Z > PI THEN DE=DE-FC
  185. 2690  RETURN
  186. 2700  REM FIND ZONE TIME OF LUNAR EVENT
  187. 2701  REM A = -1, +1, 0 => RISE, SET, TRANSIT
  188. 2702  REM ZT IS VALUE BEING REFINED
  189. 2710  FOR I= 1 TO 5
  190. 2720  Z0=ZT : Z=T-TN+(SL+ZT)/FC
  191. 2730  GOSUB 2510 : REM GET MOON'S POSITION
  192. 2735  IF ABS(LA-DE)>PI/2 THEN 2820
  193. 2740  IF A=0 THEN 2770
  194. 2745  PX=3423+187*COS(M1)+34+COS(M1-2*D0)+28*COS(2*D0)
  195. 2750  X=0.0118*PX/3423-0.00989 : GOSUB 2360
  196. 2755  IF ABS(Y)>1 THEN 2820
  197. 2760  GOSUB 2010
  198. 2770  H=A*Z : REM LOCAL HOUR ANGLE OF EVENT
  199. 2780  GOSUB 2260 : REM GET EVENT ZONE TIME
  200. 2790  IF ABS(ZT-Z0)<9.9999E-05 THEN 2830
  201. 2800  ZT=Z0+1.035*(ZT-Z0) : REM NEW GUESS
  202. 2805  IF ZT<0 THEN ZT=ZT+FC: GOTO 2805
  203. 2810  NEXT I
  204. 2820  A=1000 : REM SIGNAL NO EVENT FOUND
  205. 2830  RETURN
  206. 2850  REM SUN'S RA, DECL, AND RADIUS VECTOR
  207. 2860  MA=A0+A1*T : REM MEAN ANOMALY
  208. 2870  ML=L0+L1*T : REM MEAN CELESTIAL LONGITUDE
  209. 2880  X=SIN(ML) : Y=COS(ML) : GOSUB 2010
  210. 2890  ML=Z : REM 0<=ML<2*PI
  211. 2900  DL=2*E*SIN(MA)+1.25*E^2*SIN(2*MA)
  212. 2910  TA=MA+DL : TL=ML+DL : REM TRUE ANOM & LONG
  213. 2920  RV=(1-E^2)/(1-E*COS(TA)) : REM RADIUS VECTOR
  214. 2930  X=SIN(TL)*SIN(OB) : Y=SQR(1-X^2) : GOSUB 2010
  215. 2940  DE=Z : IF Z>PI THEN Z=Z-FC
  216. 2950  X=SIN(TL)*COS(OB) : Y=COS(TL) : GOSUB 2010
  217. 2960  RA=Z : REM SUN'S RIGHT ASCENSION
  218. 2970  RETURN
  219. 3000  REM SUBROUTINE TO DISPLAY START
  220. 3001  REM AND END OF TWILIGHT.
  221. 3010  PRINT TAB(14);"Civil Twilight";
  222. 3015  PRINT " Begins";
  223. 3020  X=-0.10453 : GOSUB 2360 : REM CIVIL
  224. 3030  IF ABS(Y)<1 THEN 3060
  225. 3040  PRINT X$;X$;T$;"            Ends";X$;X$;T$
  226. 3050  GOTO 3140
  227. 3060  S0=Z : H=-S0 : GOSUB 2260
  228. 3070  TC=0.00274*S0*SIN(OB)*COS(TL)*SIN(LA)
  229. 3075  Z=SIN(S0)*COS(LA)*(COS(DE)^3)
  230. 3080  TC=TC/Z
  231. 3090  X=ZT+TC+EO : GOSUB 2310
  232. 3100  PRINT X;Y;T$;"        Ends";
  233. 3110  H=S0 : GOSUB 2260
  234. 3120  X=ZT+TC+EO : GOSUB 2310
  235. 3130  PRINT X;Y;T$
  236. 3140  RETURN
  237. 3150  REM CARTESIAN XS, YS, ZS FROM SPHERICAL R, B, L
  238. 3160  XS=R*COS(B)*COS(L)
  239. 3170  YS=R*COS(B)*SIN(L)
  240. 3180  ZS=R*SIN(B)
  241. 3190  RETURN
  242. 3200  REM SPHER. R, B, L FROM CARTESIAN XS, YS, ZS
  243. 3210  R=SQR(XS^2+YS^2+ZS^2)
  244. 3220  X=ZS/R : Y=SQR(1-X^2) : B=ATN(X/Y)
  245. 3230  X=YS : Y=XS : GOSUB 2010 : L=Z
  246. 3240  RETURN
  247. 3250  REM ROTATE X-Y PLANE THROUGH ANGLE THETA.
  248. 3260  XP=X : YP=Y
  249. 3270  X=XP*COS(THETA)+YP*SIN(THETA)
  250. 3280  Y=YP*COS(THETA)-XP*SIN(THETA)
  251. 3290  RETURN
  252. 4000  INPUT "HOUR, MINUTE"; HR,MIN
  253. 4010  ZTH=HR+MIN/60 :ZT=ZTH*FC/24
  254. 4020  T=T-TN+(ZT+SL)/FC
  255. 4030  PRINT TAB(30);"DATA FOR";HR;MIN;T$
  256. 4040  PRINT TAB(5);"OBJECT";TAB(20);"ALTITUDE";
  257. 4050  PRINT TAB(35);"AZIMUTH";TAB(50);"DISTANCE";
  258. 4051  PRINT TAB(65);"ST. MAG."
  259. 4060  GOSUB 2860
  260. 4070  GOSUB 2210
  261. 4080  GOSUB 2150
  262. 4090  AL=PI/2-ZA
  263. 4110  PRINT TAB(5);"Sun";TAB(19);AL/TR;TAB(34);
  264. 4120  PRINT AZ/TR;TAB(49);RV
  265. 4130  Z=T: GOSUB 2500
  266. 4140  GOSUB 2200
  267. 4150  GOSUB 2150
  268. 4160  PX=3423+187*COS(M1)+34*COS(M1-2*D0)+28*COS(2*D0)
  269. 4170  RVM=8.794/PX
  270. 4180  PX=PX*SIN(ZA)/206265
  271. 4190  AL=PI/2-ZA-PX
  272. 4200  PRINT TAB(5);"Moon";TAB(19);AL/TR;TAB(34);AZ/TR;
  273. 4210  PRINT TAB(49);RVM
  274. 4300  REM ADD PLANET POSITIONS TO TABLE.
  275. 4310  DATA 2.7619, .071425, .2056, .8421, .1222
  276. 4320  DATA .3871, .5079, 0.99, "Mercury"
  277. 4330  DATA 3.9452, .027962, .0068, 1.3372, .0592
  278. 4340  DATA .7233, .9574, -2.45, "Venus"
  279. 4350  DATA 2.6379, .009146, .0934, .8640, .0323
  280. 4360  DATA 1.5237, 4.9992, -.61, "Mars"
  281. 4370  DATA 2.3245, .001450, .0484, 1.7519, .0228
  282. 4380  DATA 5.2028, 4.7793, -8.25, "Jupiter"
  283. 4390  DATA 1.2624, .000584, .0556, 1.9826, .0434
  284. 4400  DATA 9.5388, 5.9222, -8.45, "Saturn"
  285. 4410  REM MAIN LOOP
  286. 4420  FOR I=1 TO 5
  287. 4430  READ MA,MDOT,EC,AN,INC,AX,OM,MAG,P$
  288. 4440  MA=MA+MDOT*T : REM MEAN ANOMALY
  289. 4450  REM LOOP TO SOLVE KEPPLER'S EQUATION
  290. 4460  KETRY=MA
  291. 4465  Z=ABS(MA)/1E+06:IF Z<9.99E-07 THEN Z=9.99E-07
  292. 4470  KE=MA+EC*SIN(KETRY)
  293. 4480  IF ABS(KE-KETRY)<Z THEN 4500
  294. 4490  KETRY=KE : GOTO 4470
  295. 4500  RP=AX*(1-EC*COS(KE)) : REM DIST FROM SUN
  296. 4510  Y=(AX*(1-EC^2)/RP-1)/EC
  297. 4520  X=SQR(1-Y^2)
  298. 4530  IF SIN(KE)<0 THEN X=-X
  299. 4540  GOSUB 2010
  300. 4550  NU=Z : REM TRUE ANOMALY
  301. 4560  AL=NU+OM : REM ARGUMENT OF LATITUDE
  302. 4570  R=RP : L=AL : B=0 : GOSUB 3150
  303. 4580  X=YS : Y=ZS : THETA=-INC : GOSUB 3250
  304. 4590  YS=X : ZS=Y
  305. 4600  X=XS : Y=YS : THETA=-AN : GOSUB 3250
  306. 4610  XH=X : YH=Y : ZH=ZS : REM HELIO. ECLIPTIC
  307. 4620  R=RV : L=TL : B=0 : GOSUB 3150
  308. 4630  XS=XH+XS : YS=YH+YS : ZS=ZH : REM GEOCENTRIC
  309. 4640  X=YS : Y=ZS : THETA=-OB : GOSUB 3250
  310. 4650  YS=X : ZS=Y : REM EQUATORIAL SYSTEM
  311. 4660  GOSUB 3200 : RA=L : DE=B
  312. 4670  GOSUB 2210
  313. 4680  GOSUB 2150
  314. 4690  AL=PI/2-ZA
  315. 4700  PH=(R^2+RP^2-RV^2)/(2*R*RP)
  316. 4710  MAG=MAG-1.0857*LOG((1+PH)/(RP^2*R^2))
  317. 4720  PRINT TAB(5);P$;TAB(19);AL/TR;TAB(34);AZ/TR;
  318. 4730  PRINT TAB(49);R;TAB(65);MAG
  319. 4740  NEXT I
  320. 4750  Z=T-INT(T)
  321. 4760  X=(Z+0.5)*FC+ML-LO+FC
  322. 4770  IF X>FC THEN X=X-FC: GOTO 4770
  323. 4780  GOSUB 2310
  324. 4790  PRINT TAB(26);"LOCAL SIDERIAL TIME:";
  325. 4791  PRINT INT(X);"h ";INT(Y);"m"
  326. 9000  END
  327.